Cream of the Crop 22/Cream of the Crop 22.iso/program/ctlib100.zip/INSTALL.LZH/UTILS.PAS

Pascal/Delphi Source File | 1996-10-12 | 17KB | 464 lines

{**************************************************************************}
{*  BitSoft Development, L.L.C.                                           *}
{*  Copyright (C) 1995, 1996 BitSoft Development, L.L.C.                  *}
{*  All rights reserved.                                                  *}
{**************************************************************************}

unit Utils;

{$X+}

interface

uses App, Objects, Views, Drivers, MsgBox,
     BsdTest,
     Containr,
     Display, Types, Readers, Data;

var
  TestRunning : Boolean;
  { Indicates if a test is running }

  ExitTesting : Boolean;
  { Indicates if testing has been aborted }

  NonStopTesting : Boolean;
  { Indicates if no pauses must be made between sections of a test }

  TestWindow : PResultsWindow;
  { Pointer to the window that is used to display the results of the test
    currently running. }

  TestReader : PContainerReader;
  { Pointer to the reader that is being used as the interface to the
    data items in the container being currently tested. }

const
  UseNonDynamicTestRec : Boolean = False;
  { Tells Insert functions to create a non-dynamic test record instead of
    using the standard CreateItem functions, which are used to dynamically
    allocate data items. }

  UseNonDynamicTestObject : Boolean = False;
  { Tells Insert functions to create a non-dynamic test object instead of
    using the standard CreateItem functions, which are used to dynamically
    allocate data items. }

  UseNonDynamicTestStaticObject : Boolean = False;
  { Tells Insert functions to create a non-dynamic test static object
    instead of using the standard CreateItem functions, which are used to
    dynamically allocate data items. }

  TestingMemArray : Boolean = False;
  { Constant used to determine if a memory array is being tested.  If this
    is the case, when an Item in the array must be deleted, it will be freed
    first. }

var
  NonDynamicRec : TTestRec;
  { Variable used in tests using non-dynamically allocated data. }

  NonDynamicObject : TTestObject;
  { Variable used in tests using non-dynamically allocated data. }

  NonDynamicStaticObject : TTestStaticObject;
  { Variable used in tests using non-dynamically allocated data. }

var
  CreateItem : TCreateFunction;
  { This function is used to construct the items that will be inserted
    in the container being tested. }

function CanStartNewTest : Boolean;
{ Returns True if no other tests are running and therefore, a new test
  can be started . }

procedure DisplayFooter;
{ Displayes a notice that the test has ended. }

procedure DisplayHeader;
{ Displays the instructions when starting a test. }

function DisplayMessage (AMessage:String): Boolean;
{ Displays a message at the bottom of the screen. }

procedure EndTest;
{ Displays a message indicating that the test has finished and the resets
  the state of the application and of test variables.  This procedure
  must always be called immediatly after any test. }

procedure EraseMessage;
{ Erases a message that was displayed using DisplayMessage. }

procedure InitTest(Reader: PContainerReader; Window: PResultsWindow;
  CreateItemFunc : TCreateFunction);
{ Sets the value of several variables used throught tests and displays
  the test's header.  This procedure must always be called immediatly
  before starting any test. }

procedure NotifyDataChange;
{ Notifies the current scroller that the data has changed. }

procedure PauseTest;
{ Makes a pause and waits for user instructions. }

procedure ResetApplication;
{ Resets the state of the application after a test .}

procedure StartTest(TestHeader, TestSubHeader : string);
{ Diplays the headers for the next section of the test and starts the timer. }

procedure StopTest;
{ Stops the timer and displays the time elapsed. }

procedure WriteHeader(TestHeader : string);
{ Displays the header of the test. }

procedure WriteNumResult(ResultString: string; Result: LongInt);
{ Displays a subheader with a numeric result. }

procedure WriteResult(ResultString: string);
{ Displays a subheader with a string result. }

procedure WriteSubHeader(TestSubHeader : string);
{ Displays the subheader (one line description) for the next section of the
  test. }

procedure WriteTime;
{ Displays the time that the last time took to complete. }

type
  PMessageLine = ^TMessageLine;
  TMessageLine = object(TView)
  { Displays the string stored in the StatusMessage attribute.  This object
    is used to display status line messages }
      StatusMessage : String[79];
    constructor Init (Bounds:TRect; AMessage:String);
    procedure Draw; virtual;
  end; { TMessageLine }

var
  MessageLine : PMessageLine;
  { Global variable used to display messages at the bottom of the screen }

implementation

{****************************************************************************}
{ TMessageLine object                                                        }
{****************************************************************************}
{****************************************************************************}
{ TMessageLine.Init                                                          }
{****************************************************************************}
constructor TMessageLine.Init(Bounds:TRect; AMessage:String);
begin
  TView.Init(Bounds);
  StatusMessage := ' '+AMessage;
end;

{****************************************************************************}
{ TMessageLine.Draw                                                          }
{****************************************************************************}
procedure TMessageLine.Draw;
var
  B : TDrawBuffer;
  C : Byte;
begin
  C := GetColor(2);
  MoveChar(B, ' ', C, Size.X);
  MoveStr(B, StatusMessage, C);
  WriteLine(0, 0, Size.X, 1, B);
end;

{****************************************************************************}
{ CanStartNewTest                                                            }
{****************************************************************************}
function CanStartNewTest : Boolean;
begin
  if not TestRunning
    then CanStartNewTest := True
    else begin
           MessageBox('Please finish the current test before testing '+
             'another object.', nil, mfWarning + mfOkButton);
           CanStartNewTest := False;
         end; { else }
end;

{****************************************************************************}
{ DisplayFooter                                                              }
{****************************************************************************}
procedure DisplayFooter;
begin
  with TestWindow^ do
  begin
    Writeln(T);
    Writeln(T, '-------------------------------------------------------------');
    Writeln(T, 'Done testing the object.  No errors ocurred.');
    Writeln(T);
    Writeln(T, 'Note: if many items were created and the program is running');
    Writeln(T, 'in real mode, it may take a while after closing the window,');
    Writeln(T, 'before all items in the container get disposed of.');
    Writeln(T);
    Writeln(T, 'End of test.');
  end; { with }
end;

{****************************************************************************}
{ DisplayHeader                                                              }
{****************************************************************************}
procedure DisplayHeader;
begin
  with TestWindow^ do
  begin
    Writeln(T, 'After each step in the test, please press (N) to go to the');
    Writeln(T, 'next test, (C) for continuous testing, or (X) to cancel.');
    Writeln(T);
    Writeln(T, 'Press (N) or (C) now to start testing.');
    Writeln(T, '-------------------------------------------------------------');
    Writeln(T, '');
  end; { with }
end;

{****************************************************************************}
{ DisplayMessage                                                             }
{****************************************************************************}
function DisplayMessage (AMessage : String) : Boolean;
var
  R : TRect;
begin
  DisplayMessage := False;
  Application^.GetExtent(R);
  R.A.Y := R.B.Y - 1;
  if MessageLine <> NIL then
    begin
      MessageLine^.StatusMessage := ' ' + AMessage;
      MessageLine^.Draw;
    end {...if MessageLine <> NIL }
  else
    begin
      MessageLine := New(PMessageLine, Init(R, AMessage));
      if MessageLine^.Valid(cmValid) = True then
        begin
          Application^.Insert(MessageLine);
          DisplayMessage := True;
        end {...if MessageLine^.Valid(cmValid) = True }
      else
        MessageLine := NIL;
    end; {...if/else }
end;

{****************************************************************************}
{ EndTest                                                                    }
{****************************************************************************}
procedure EndTest;
begin
  if not ExitTesting
    then begin
           DisplayFooter;
           ResetApplication;
         end; { if }
end;

{****************************************************************************}
{ EraseMessage                                                               }
{****************************************************************************}
procedure EraseMessage;
begin
  if MessageLine <> nil
    then Dispose(MessageLine , Done);
  MessageLine := nil;
end;

{****************************************************************************}
{ InitTest                                                                   }
{****************************************************************************}
procedure InitTest(Reader: PContainerReader; Window: PResultsWindow;
  CreateItemFunc : TCreateFunction);
var
  OldTitle : string;
begin
  TestRunning := True;
  ExitTesting := False;
  NonStopTesting := False;
  TestReader := Reader;
  TestWindow := Window;
  CreateItem := CreateItemFunc;
  with TestWindow^ do
  begin
    OldTitle := Title^;
    DisposeStr(Title);
    Title := NewStr(OldTitle + ' (testing)');
  end; { with }
  Desktop^.Insert(TestWindow);
  DisplayHeader;
  PauseTest;
end;

{****************************************************************************}
{ NotifyDataChanged                                                          }
{****************************************************************************}
procedure NotifyDataChange;
begin
  TestWindow^.Scroller^.Reader^.HasChanged := True;
end;

{****************************************************************************}
{ Pause                                                                      }
{****************************************************************************}
procedure PauseTest;
var
  Event : TEvent;
begin
  TestWindow^.Redraw;
  if NonStopTesting
    then begin
           Application^.Idle;
           Exit;
         end; { if }
  Application^.GetEvent(Event);
  repeat
    Application^.HandleEvent(Event);
    Application^.Idle;
    Application^.GetEvent(Event);
  until ((Event.What = evKeyDown) and
        (UpCase(Event.CharCode) in ['C', 'X', 'N'])) or
        ((Event.What = evCommand) and ((Event.Command = cmClose) or
        (Event.Command = cmQuit)));
  if Desktop^.Current = PView(TestWindow)
    then if ((Event.What = evCommand) and ((Event.Command = cmClose) or
            (Event.Command = cmQuit)))
           then begin
                  Writeln(TestWindow^.T);
                  Writeln(TestWIndow^.T);
                  Writeln(TestWindow^.T, 'Test aborted...');
                  ExitTesting := True;
                  ResetApplication;
                  Application^.HandleEvent(Event);
                end { case of }
           else case UpCase(Event.CharCode) of
                  'X' : begin
                          Writeln(TestWindow^.T);
                          Writeln(TestWIndow^.T);
                          Writeln(TestWindow^.T, 'Test aborted...');
                          ExitTesting := True;
                          ResetApplication;
                        end; { case of }
                  'C' : NonStopTesting := True;
                end { case of }
    else if (Event.What = evCommand) and (Event.Command = cmQuit)
           then Desktop^.Current := TestWindow
           else if Event.What = evKeyDown
                  then begin
                         MessageBox('Please select the current test window '+
                           'before continuing.', nil, mfError + mfOkButton);
                         Pause;
                       end { if }
                  else begin
                         MessageBox('Please close the current test window, '+
                           'before continuing.', nil, mfError + mfOkButton);
                         PauseTest;
                       end; { else }
end;

{****************************************************************************}
{ ResetApplication                                                           }
{****************************************************************************}
procedure ResetApplication;
var
  OldTitle : string;
begin
  with TestWindow^ do
  begin
    OldTitle := Title^;
    DisposeStr(Title);
    Title := NewStr(Copy(OldTitle, 1, Length(OldTitle) -10));
  end;
  TestWindow^.ReDraw;
  TestRunning := False;
end;

{****************************************************************************}
{ StartTest                                                                  }
{****************************************************************************}
procedure StartTest(TestHeader, TestSubHeader : string);
begin
  WriteHeader(TestHeader);
  WriteSubHeader(TestSubHeader);
  SetInitTime;
end;

{****************************************************************************}
{ StopTest                                                                   }
{****************************************************************************}
procedure StopTest;
begin
  SetFinalTime;
  WriteTime;
end;

{****************************************************************************}
{ WriteHeader                                                                }
{****************************************************************************}
procedure WriteHeader(TestHeader : string);
begin
  with TestWindow^ do
  begin
    writeln(T);
    writeln(T, 'Testing : ', TestHeader);
    writeln(T);
  end; { with }
end;

{****************************************************************************}
{ WriteNumResult                                                             }
{****************************************************************************}
procedure WriteNumResult(ResultString: string; Result: LongInt);
begin
  WriteSubHeader(ResultString);
  Writeln(TestWindow^.T, Result:13);
end;

{****************************************************************************}
{ WriteResult(var                                                            }
{****************************************************************************}
procedure WriteResult(ResultString: string);
begin
  WriteSubHeader('Result:');
  Writeln(TestWindow^.T, ResultString:13);
end;

{****************************************************************************}
{ WriteSubHeader                                                             }
{****************************************************************************}
procedure WriteSubHeader(TestSubHeader : string);
var
  S : string;
  P : Integer;
const
  MaxLineSize = 48;
begin
  if Length(TestSubHeader) > MaxLineSize
    then begin
           S := Copy(TestSubHeader, 1, MaxLineSize);
           P := MaxLineSize;
           while S[P] <> ' ' do
             Dec(P);
           S := Copy(TestSubHeader, 1, P);
           writeln(TestWindow^.T, S:48);
           TestSubHeader := Copy(TestSubHeader, Succ(P),
             Succ(Length(TestSubHeader) - Succ(P)));
         end; { if }
  write(TestWindow^.T, TestSubHeader:48);
end;

{****************************************************************************}
{ WriteTime                                                                  }
{****************************************************************************}
procedure WriteTime;
begin
  writeln(TestWindow^.T, CalculateTime:13);
end;

begin
  TestRunning := False;
  CreateItem := nil;
end.